home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / Pocket Forth rel.5 / Source code / daSource / dSupport.txt < prev    next >
Encoding:
Text File  |  1991-07-19  |  11.7 KB  |  448 lines  |  [TEXT/EDIT]
  1. ; this file is dSupport.txt
  2. ; Mon Feb 15, 1988 10:22:13 menus
  3. ; Thu Feb 18, 1988 00:24:50 redo the control routine structure
  4. ;                key events are now subroutines
  5. ; Wed Mar 30, 1988 13:37:36 opener routine
  6. ; Thu Apr 07, 1988 16:00:59 nested loads
  7. ; Mon Apr 18, 1988 14:06:37 restructure variables, echo, version, pblk in d4
  8. ; Mon Apr 25, 1988 15:10:34 macros
  9. ; Fri Apr 29, 1988 10:36:59 cursor change handler
  10. ; Sun May 01, 1988 10:40:36 fix emptyFS
  11. ; Tue May 10, 1988 01:28:38 ?terminal now writes event record to pad
  12.  
  13. ; ----- Mac Data ------
  14.  
  15. theWindow:    DC.L    0        ; the DA's wptr & stuff
  16.     WContRect:    DC.W    0,0
  17.     WSize:    DC.W    WHeight,WWidth
  18.  
  19. Activate:    DC.W    drop-base    ; drop act/deact flag
  20. Update:        DC.W    curs-base
  21. Button:        DC.W    beep-base
  22. YourMenu:    DC.W    menus-base
  23. Runner:        DC.W    null-base
  24. Closer:        DC.W    null-base
  25. Version:    DC.W    doabout-base    ; the about thingy
  26. Opener:        DC.W    prompt-base    ; open routine 3/30/88
  27. Echo:        DC.W    -1
  28. MyID:        DC.W    0
  29. KeyDown:    DC.W    inKey-base    ; text input
  30. Cursor:        DC.W    null-base
  31.  
  32. oldSSize:    DC.W    0
  33. oldStackH:    DC.L    0
  34.  
  35. TextO:        DC.L    0
  36. TextE:        DC.L    0
  37. TextH:        DC.L    0
  38. FStack:        DCB.L    5,0        ; text block handles
  39. FOfsets:    DCB.L    5,0        ; text block offsets
  40. FEnds:        DCB.L    5,0        ; text block ends
  41. FSPtr:        DC.W    -4        ; file stack pointer
  42.  
  43. Events:        DC.W    return-base    ; null event
  44.         DC.W    buttDnEvt-base
  45.         DC.W    return-base    ; button up
  46.         DC.W    keyDnEvt-base
  47.         DC.W    return-base    ; key up
  48.         DC.W    keyDnEvt-base    ; auto key
  49.         DC.W    UpdateEvt-base
  50.         DC.W    return-base    ; disk inserted
  51.         DC.W    ActivateEvt-base
  52.         
  53. Registers:    DCB.L    6,0        ; save Dict/Counter/DP-IS/PS
  54. PStackH:    DC.L    0
  55.  
  56. oldKeyDown:    DC.W    0        ; hold key handler addr during key
  57. Scratch:    DC.L    0
  58.  
  59. Menus:        DC.W    emenu-base
  60.         DC.W    emenu-base
  61. EMenu:        DC.W    beep-base    ; undo
  62.         DC.W    null-base    ; -
  63.         DC.W    beep-base    ; cut
  64.         DC.W    beep-base    ; copy
  65.         DC.W    paste-base    ; paste
  66.         DC.W    beep-base    ; clear
  67.  
  68. ; ----- Forth's Data ------
  69.  
  70. TermBuf:    DCB.B    84,32        ; the input line buffer
  71. IntA7:        DC.L    0        ; applications rStack
  72. RZero:        DC.L    0        ; empty rStack
  73. UFlow:        DC.L    0        ; pstack underflow buffer (2bytes)
  74. SZero:        DC.L    0        ; empty pStack
  75. Expand:        DC.L    0        ; abs.addr in locked DRVR
  76. FreePt:        DC.W    DictEnd-base    ; "here"'s relative addr
  77. FreeSz:        DC.W    4096        ; number of bytes available
  78. DictPt:        DC.W    task-theLink    ; last word defined
  79. NBase:        DC.W    10        ; number base
  80. Held:        DC.W    0        ; HLD address
  81. DoesAddr:    DC.L    0        ; "does>" jump address
  82. fcolon:        DC.B    0        ; defining flag
  83. fimmed:        DC.B    0        ; immediate definition flag    
  84. fneg:        DC.B    0        ; negative sign flag
  85. fint:        DC.B    $80        ; key or clipboard
  86. fmacro:        DC.W    0        ;   macro flag+filler
  87.  
  88. DictControl:    ; ----- Control routine ------
  89.     JSR    SetFRegs        ; set the Forth registers    
  90.     MOVE.L    A7,IntA7-base(BP)    ; put return address in IntA7
  91.     SUBA.L    #16,A7            ; allocate a underflow buffer
  92.     MOVE.L    A7,Rzero-base(BP)
  93.     MOVE.L    theWindow-base(BP),-(SP)
  94.     _SetPort            ; set this window
  95.  
  96.     MOVE.L    D4,A0            ; A0 has the param block's address
  97.     MOVE    csCode(A0),D0        ; d0 has the message
  98.  
  99.     ; Event Message
  100.     CMPI    #accEvent,D0        ; event message?
  101.     BNE.S    @0
  102.     MOVEA.L    csEvent(A0),A0        ; get the event record
  103.     MOVE    evtNum(A0),D0        ; get event in D0
  104.     ANDI    #$0F,D0
  105.     ADD    D0,D0
  106.     LEA    Events-base(BP),A1    ; jump to: ...
  107.     MOVE    0(A1,D0.W),D0        ;  ... ActivateEvt, ButtDnEvt, ...
  108.     JMP    0(BP,D0.W)        ;  ... UpDateEvt or KeyDnEvt
  109.     
  110.     ; Idle Message
  111.     @0:    CMPI    #accRun,D0        ; periodic run message?
  112.     BNE.S    @1
  113.     MOVE    Runner-base(BP),D0
  114.     BRA.S    @5            ; jump to the idle handler
  115.     
  116.     ; cursor message
  117.     @1:    CMPI    #accCursor,D0        ; change cursor message?
  118.     BNE.S    @2
  119.     MOVE    cursor-base(BP),D0
  120.     BRA.S    @5            ; jump to the cursor handler
  121.     
  122.     ; Menu Message
  123.     @2:    CMPI    #accMenu,D0        ; menu message
  124.         BNE.S    @3
  125.     MOVE    csMenu(A0),D0        ; D0 has the item number
  126.     SUBQ    #1,D0            ; D0 has the item index
  127.     ADD    D0,D0            ; D0 has menu list offset
  128.     MOVE    Yourmenu-base(BP),D1    ; D1 has menus relative addr
  129.     BRA.S    @4            ; execute the menu
  130.  
  131.     ; Edit message
  132.     @3:    CMPI    #accUndo,D0        ; edit menu message?
  133.     BMI.S    return
  134.     SUBI    #accUndo,D0        ; normalize message# to 0-5
  135.     ADD    D0,D0            ; D0 has offset into emenu
  136.     MOVE    Yourmenu-base(BP),D1    ; D1 has menus relative addr
  137.     ADDQ    #2,D1            ; D1 has menus+2 rel addr
  138.  
  139.     @4:    MOVE    0(BP,D1.W),D1        ; D1 has emenu rel addr
  140.     ADD    D1,D0            ; D0 has emenu+offset rel addr
  141.     MOVE    0(BP,D0.W),D0        ; D0 has the handler' rel addr
  142.     @5:    JSR    0(BP,D0.W)        ; execute subroutine
  143.  
  144. Return:    JSR    SaveFRegs-base(BP)    ; save the current forth registers
  145.     MOVE.L    IntA7-base(BP),A7    ; restore the return address
  146.     RTS                ; and go back to the DRVR
  147.  
  148. ; First Line Event Handlers
  149.  
  150. ActivateEvt:
  151.     MOVE    evtMeta(A0),-(PS)
  152.     ANDI    #1,(PS)
  153.     MOVE    Activate-base(BP),D0
  154.     BRA.S    revt
  155.  
  156. ButtDnEvt:
  157.     MOVE    Button-base(BP),D0
  158.   revt:    JSR    0(BP,D0.W)
  159.     BRA.S    return
  160.  
  161. UpDateEvt:
  162.     MOVE.L    thewindow-base(BP),-(SP)
  163.     MOVE.L    (SP),-(SP)
  164.     _BeginUpdate
  165.     MOVE    update-base(BP),D0
  166.     JSR    0(BP,D0.W)
  167.     _EndUpdate
  168.     BRA.S    return
  169.     
  170. KeyDnEvt:
  171.     MOVE.W    evtASCII(A0),-(PS)    ; push key data
  172.     MOVE    Keydown-base(BP),D0
  173.     JSR    0(BP,D0.W)        ; jump to the vector
  174.  kDone:    BSR.S    Curs            ; draw the cursor
  175.     BRA.S    return
  176.  
  177. ; Un-named subroutines
  178.  
  179. SaveFRegs:
  180.     LEA    Registers-base(BP),A0
  181.     MOVEM.L    D6-D7/A2-A4/A6,(A0)
  182.     RTS
  183.  
  184. SetFRegs:    ; restore the forth registers
  185.     LEA    Registers,A0
  186.     MOVEM.L    (A0),D6-D7/A2-A4/A6
  187.     RTS
  188.         
  189. TextNormal:
  190.     _PenNormal            ; 1X1, black, patcopy
  191.     MOVE    #4,-(SP)        ; Monaco
  192.     _TextFont
  193.     MOVE    #0,-(SP)        ; plain text
  194.     _TextFace
  195.     MOVE    #9,-(SP)        ; 9 point
  196.     _TextSize
  197.     MOVE    #0,-(SP)        ; srcCopy
  198.     _TextMode
  199.     RTS    
  200.     
  201. NoCurs:    MOVE    #10,-(SP)        ; SrcXor mode
  202.     _PenMode
  203.   Curs:    MOVE.L    #$00000006,-(SP)    ; move 6 pixels to the right
  204.     _Move
  205.     MOVE.L    #$0000FFFA,-(SP)    ; draw 6 pixels to the left
  206.     _Line
  207.     _PenNormal
  208.     RTS
  209.  
  210. altKey:    BSR.S    TextNormal        ; font, mode, size etc
  211.     BSR.S    NoCurs            ; erase the cursor
  212.     MOVE    oldKeyDown-base(BP),KeyDown-base(BP) ; set old key vector
  213.     BSR.S    RestoreRStack        ; put pforth addrs on rstack
  214.     MOVE.L    oldStackH-base(BP),A0
  215.     MOVEQ    #0,D0
  216.     _SetHandleSize            ; shrink old stack data block
  217.     ANDI    #$FF,(PS)        ; mask out ascii
  218.     RTS                ; return from "key"
  219.  
  220. RestoreRStack:
  221.     MOVE.L    (SP)+,A1        ; save calling address
  222.     MOVE.L    oldStackH-base(BP),A0
  223.     MOVE.L    (A0),A0            ; get addr of old stack data block
  224.     MOVEQ    #0,D0
  225.     MOVE    oldSSize-base(BP),D0    ; get size of block to move
  226.     ADD.L    D0,A0
  227.     @0: MOVE.L    -(A0),-(SP)
  228.     SUBQ.L    #4,D0
  229.     BGT.S    @0
  230.     JMP    (A1)            ; return to calling address
  231.  
  232. QTCode:        ; "?terminal" code
  233.     CLR    -(SP)            ; ?terminal's routine
  234.     MOVE    #40,-(SP)        ; test just for keypresses
  235.     PEA    40(DP)            ; put the data at 'pad'
  236.     _EventAvail
  237.     MOVE    (SP)+,-(PS)
  238.     MOVE.L    #$0000FFFF,D0
  239.     _FlushEvents            ; all events out!
  240.     RTS
  241.  
  242. KeyCode:    ; "key" code
  243.     MOVE.L    RZero-base(BP),D5
  244.     SUB.L    SP,D5
  245.     MOVEQ    #0,D0
  246.     MOVE    D5,D0
  247.     MOVE    D0,oldSSize-base(BP)    ; set old stack size
  248.     MOVE.L    oldStackH-base(BP),A0
  249.     _SetHandleSize
  250.     MOVE.L    (A0),A0            ; A0 points to old stack data block
  251.     @0:    MOVE.L    (SP)+,(A0)+        ; save RStack
  252.     SUBQ    #4,D5
  253.     BGT.S    @0
  254.     MOVE    KeyDown-base(BP),oldKeyDown-base(BP)  ; save the old keydown
  255.     MOVE    #altKey-base,keydown-base(BP)    ; reset key handler
  256.     JMP    kDone-base(BP)            ; return to application
  257.  
  258. Xpect:    MOVEM.L    D5/IS,-(SP)        ; "expect"'s routine
  259.     JSR    swapp-base(BP)        ; leave number of chars on stack
  260.     MOVE    (PS)+,D0        ; addr
  261.     LEA    0(BP,D0.W),IS        ; set IS to the input address
  262.     CLR    Counter
  263.     @0:    BSR.S    keycode
  264.     MOVE    (PS)+,D5
  265.     CMPI    #CR,D5            ; if key = CR
  266.     BNE.S    @1
  267.     MOVE.B    #BL,0(IS,Counter)
  268.     CLR.B    1(IS,Counter)
  269.     BRA.S    @3
  270.     @1:    CMPI    #BS,D5            ; if key = backspace
  271.     BNE.S    @2
  272.     TST    Counter            ; do nothing if first key is BS
  273.     BEQ.S    @0
  274.     SUBQ    #1,Counter        ; decriment counter
  275.     JSR    dodel-base(BP)
  276.     JSR    space-base(BP)        ;    ... rubout char
  277.     JSR    dodel-base(BP)
  278.     BRA.S    @0
  279.     @2:    MOVE.B    D5,0(IS,Counter)    ; stash the key into input buffer
  280.     ADDQ    #1,Counter
  281.     MOVE    D5,D0
  282.     BSR.S    emitcode
  283.     CMP    (PS),Counter        ; is count=number of chars to get?
  284.     BNE.S    @0
  285.     @3:    BSR.S    docr
  286.     ADDQ.L    #2,PS            ; drop the count
  287.     MOVEM.L    (SP)+,D5/IS
  288.     RTS
  289.  
  290. EmitCode:    ; prints contents of D0 on current port at current location
  291.     CMP.B    #CR,D0            ; is it a <cr>
  292.     BEQ.S    doCR
  293.     CMP.B    #BS,D0            ; is it a <del>?
  294.     BEQ.S    doDEL
  295.     ANDI    #$FF,D0
  296.     MOVE    D0,-(A7)
  297.     _DrawChar
  298.     
  299.     PEA    Scratch-base(BP)
  300.     _GetPen                ; get current pen location
  301.     MOVE    Scratch+2-base(BP),D1    ; get h pos
  302.     MOVE    WContRect+6-base(BP),D0    ; right coord of WContRect
  303.     CMP    D0,D1            ; is the position beyond the edge
  304.     BLS.S    emitr            ; no
  305.     
  306.  doCR:    PEA    Scratch-base(BP)
  307.     _GetPen                ; get current pen location
  308.     MOVE    Scratch-base(BP),D1
  309.     MOVE    WContRect+4-base(BP),D0    ; bottom coord of WContRect
  310.     SUB    #LHeight,D0
  311.     CMP    D0,D1            ; is the position below the window
  312.     BLS.S    @0            ; no
  313.     
  314.     ; yes it is below the window bottom, so scroll up LHeight pixels
  315.     CLR.L    -(A7)            ; Make room for a region handle.
  316.     _NewRgn                ; get handle into (A7)
  317.     PEA    WContRect-base(BP)    ; rect to scroll
  318.     CLR    -(A7)            ; no horiz.
  319.     MOVE    #-LHeight,-(A7)        ; -11 pix. vert.
  320.     MOVE.L    8(A7),-(A7)        ; push the region handle
  321.     _ScrollRect
  322.     _DisposRgn
  323.     
  324.     MOVE    WContRect+4-base(BP),D1    ; bottom coord of WContRect
  325.     SUBQ    #4,D1            ; change #3 to #4
  326.     BRA.S    @1
  327.  
  328.     @0: ADD    #LHeight,D1        ; Add line height to pen location
  329.     @1:    MOVE    #1,-(A7)
  330.     MOVE    D1,-(A7)
  331.     _MoveTo
  332.  emitr:    RTS
  333.  
  334.  doDEL:    ; it's a <del>
  335.     PEA    Scratch-base(BP)
  336.     _GetPen                ; get current pen location
  337.     MOVE    Scratch+2-base(BP),D1
  338.     CMP    #6,D1            ; first column?
  339.     BLT.S    @0            ; just return
  340.     SUB    #6,D1            ; back up
  341.     MOVE    D1,-(SP)
  342.     MOVE    Scratch-base(BP),-(SP)
  343.     _MoveTo
  344.     @0:    RTS
  345.  
  346. ClearTermBuf:
  347.     MOVEQ    #76,D0
  348.     LEA    TermBuf-base(BP),IS
  349.     @0:    MOVE.L    #$20202020,0(IS,D0)    ; fill line buffer with blanks
  350.     SUBQ.B    #4,D0
  351.     BGE.S    @0
  352.     RTS
  353.  
  354. EmptyFS: ; clear pending loads from the file stack
  355.     TST    fsptr-base(BP)
  356.     BMI.S    @1
  357.     LEA    fstack-base(BP),A1
  358.     MOVE    fsptr-base(BP),D0
  359.     MOVE.L    0(A1,D0),A0
  360.     CLR.L    0(A1,D0)
  361.     MOVE.L    A0,D1            ; dont try to dispose of nil handle*
  362.     BEQ.S    @0            ; *
  363.     CMPA.L    TextH-base(BP),A0
  364.     BEQ.S    @0
  365.     _DisposHandle
  366.     @0:    SUBQ    #4,fsptr-base(BP)
  367.     BRA.S    emptyfs
  368.     @1:    RTS
  369.  
  370. Paste:    JSR    nocurs-base(BP)
  371.     CLR.L    -(SP)
  372.     MOVE.L    TextH-base(BP),-(SP)    ; handle to the scrap data
  373.     MOVE.L    #'TEXT',-(SP)
  374.     PEA    TextO-Base(BP)
  375.     _GetScrap
  376.     MOVE.L    (SP)+,TextE-base(BP)    ; put the length at TextE
  377.     MOVE.L    TextH-base(BP),A0    ; get a handle to the scrap data
  378.     MOVE.L    (A0),D0            ; derefrence the scrap handle
  379.     MOVE.L    D0,TextO-base(BP)    ; set TextO to start of scrap data
  380.     ADD.L    D0,TextE-base(BP)    ; set TextE to end of scrap data
  381.     _HLock                ; don't let data move during paste
  382.     CLR    fsptr-base(BP)
  383.     MOVE.L    TextH-base(BP),fstack-base(BP)
  384.     MOVE.L    TextO-base(BP),fofsets-base(BP)
  385.     MOVE.L    TextE-base(BP),fends-base(BP)
  386.     go:    CLR.B    fint-base(BP)        ; leave keyboard mode
  387.     JMP    CRet-base(BP)        ; get next line
  388.  
  389. Pasting:
  390.     JSR    ClearTermBuf-base(BP)
  391.     CLR.L    D5            ; clear the character count
  392.     CLR.L    D0            ; and the character
  393.     MOVE.L    TextO-base(BP),A0    ; set the input address
  394.     @0:    MOVE.B    0(A0,D5.W),D0        ; BEGIN  get a character
  395.     CMP.B    #CR,D0            ;     is it not a CR?
  396.     BEQ.S    @1
  397.     CMPI.B    #78,D5            ;     or 78 characters in buffer
  398.     BGE.S    @1            ; WHILE
  399.         MOVE.B    D0,0(IS,D5)        ;     stash it into buffer
  400.     ADDQ.B    #1,D5            ;     increment count
  401.     BRA.S    @0            ; REPEAT
  402.     @1:    ADDQ.B    #1,D5            ; increment count
  403.     MOVE.B    #CR,0(IS,D5)        ; stash CR into buffer
  404.     MOVE    D5,D0            ; preserve count for TYPE
  405.     ADD.L    TextO-base(BP),D0
  406.     MOVE.L    D0,TextO-base(BP)    ; TextO=TextO+char.count
  407.     CMP.L    TextE-base(BP),D0    ; IS the block done (TextO≥TextE)?
  408.     BMI.S    tandr            ; just type and return if not.
  409.     
  410.     MOVE    fsptr-base(BP),D0
  411.     LEA    fstack-base(BP),A0
  412.     MOVE.L    0(A0,D0.W),A0
  413.     _HUnlock            ; unlock the block
  414.     CMPA.L    TextH-base(BP),A0
  415.     BEQ.S    @2            ; keep the scrap block
  416.  
  417.     _DisposHandle            ; dispose of loaded blocks
  418.     @2:    SUBQ    #4,fsptr-base(BP)    ; pop fstack
  419.     BMI.S    @3            ; branch if no pending loads
  420.  
  421.     MOVE    fsptr-base(BP),D0
  422.     LEA    fofsets-base(BP),A0    ; set TextO to (fofsets+fsptr)
  423.     MOVE.L    0(A0,D0.W),TextO-base(BP)
  424.     LEA    fends-base(BP),A0
  425.     MOVE.L    0(A0,D0.W),TextE-base(BP)
  426.     BRA.S    tandr
  427.  
  428.     @3:    BSET.B    #7,fint-base(BP)    ; set keyboard mode
  429.  tandr:    TST    echo-base(BP)
  430.     BNE.S    @4
  431.     RTS
  432.     
  433.     @4:    JSR    tib-base(BP)
  434.     MOVE    D5,-(PS)
  435.     JSR    type-base(BP)
  436.     JMP    doCR-base(BP)        ; TIB count TYPE CR ;
  437.  
  438. DoAbout:
  439.     CLR.L    -(SP)
  440.     MOVE.L    #'P4th',-(SP)
  441.     MOVE    myid-base(BP),-(SP)    ; Resource ID of P4th
  442.     _GetResource
  443.     MOVE.L    (SP),A0
  444.     MOVE.L    (A0),-(SP)        ; text address
  445.     _DrawString
  446.     _ReleaseResource
  447.     JMP    docr-base(BP)
  448.